Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue46/packages/AppSupportU.pas

Pascal/Delphi Source File | 1999-05-04 | 7.6 KB | 304 lines

unit AppSupportU;

interface

uses
  Classes, Windows, SysUtils, Forms;

type
  PPackageRec = ^TPackageRec;
  TPackageRec = record
    FileName,
    Description: String;
    Module: HModule;
    Group: Integer;
  end;

  EPackageLoadError = class(EPackageError);

var
  PackageList: TList;

//Registration routine for adding pages to the page control
procedure InternalRegisterPages(Group: Integer; const Page: String; PageForms: array of TForm);
procedure LoadPage(Group: Integer; const Page: String; PageForm: TForm);
procedure UnloadPages(Group: Integer);

//Routines used for package group management
function NewAppGroup: Integer;
procedure FreeAppGroup(Group: Integer);

//Routines used for package management
procedure InitializePackageSupport;
procedure FinalizePackageSupport;

procedure LoadPackagesStoredInRegistry;
procedure StorePackagesInRegistry;

function LoadCustomPackage(const Name: string): HModule;
procedure UnloadCustomPackage(PackageModule: HModule);

procedure FormatPackagesAsDisplayList(List: TStrings);

implementation

uses
  Registry, Dialogs, ComCtrls, CommonHookU, AppMainFormU;

type
  PPageFormRec = ^TPageFormRec;
  TPageFormRec = record
    Group: Integer;
    PageForm: TForm;
    TabSheet: TTabSheet;
  end;

var
  PageFormList: TList = nil;

procedure InternalRegisterPages(Group: Integer; const Page: String; PageForms: array of TForm);
var
  Loop: Integer;
begin
  for Loop := Low(PageForms) to High(PageForms) do
    LoadPage(Group, Page, PageForms[Loop])
end;

procedure LoadPage(Group: Integer; const Page: String; PageForm: TForm);
var
  P: PPageFormRec;
begin
  if PageFormList = nil then
    PageFormList := TList.Create;
  New(P);
  P.Group := CurrentGroup;
  P.PageForm := PageForm;
  P.TabSheet := TTabSheet.Create(nil);
  PageFormList.Insert(0, P);
  P.TabSheet.Parent := MainForm.PageControl;
  P.TabSheet.PageControl := MainForm.PageControl;
  P.TabSheet.Caption := Page;
  MainForm.PageControl.ActivePage := P.TabSheet;
  with P.PageForm do
  begin
    Hide;
    Left := 0;
    Top := 0;
    BorderStyle := bsNone;
    Parent := P.TabSheet;
    WindowState := wsMaximized;
    Show
  end;
end;

procedure UnloadPages(Group: Integer);
var
  I: Integer;
  P: PPageFormRec;
  PageCtl: TPageControl;
begin
  if not Assigned(PageFormList) then
    Exit;
  I := PageFormList.Count - 1;
  while I > -1 do
  begin
    P := PageFormList[I];
    if P.Group = Group then
    begin
      PageCtl := P.TabSheet.PageControl;
      //Switch to a page that we are not removing
      if Assigned(PageCtl) and (PageCtl.ActivePage = P.TabSheet) then
        PageCtl.SelectNextPage(False);
      P.PageForm.Free;
      P.TabSheet.Free;
      PageFormList.Delete(I);
      Dispose(P);
    end;
    Dec(I);
  end;
end;

//Package group management support
var
  AppGroupList: TBits = nil;

function NewAppGroup: Integer;
begin
  if AppGroupList = nil then
    AppGroupList := TBits.Create;
  CurrentGroup := AppGroupList.OpenBit;
  AppGroupList[CurrentGroup] := True;
  Result := CurrentGroup;
end;

procedure FreeAppGroup(Group: Integer);
begin
  //Destroy any forms that were created by this group
  UnloadPages(Group);
  //Free group number for later possible re-use
  if (Group >= 0) and (Group < AppGroupList.Size) then
    AppGroupList[Group] := False;
end;

procedure InitializePackageSupport;
begin
  //Create package list
  PackageList := TList.Create;
  RegisterPagesProc := InternalRegisterPages
end;

procedure FinalizePackageSupport;
begin
  //Unload packages
  while PackageList.Count > 0 do
    UnloadCustomPackage(PPackageRec(PackageList[0]).Module);
  //Delete package list
  PackageList.Free;
  AppGroupList.Free;
  //Free page control form list
  PageFormList.Free
end;

const
{$ifdef Ver100}
  RegPath = 'Software\Oblong\AppProject3';
{$else}
  RegPath = 'Software\Oblong\AppProject4';
{$endif}
  RegSection = 'Known Modules';

procedure LoadPackagesStoredInRegistry;
var
  Pkgs: TStrings;
  Loop: Integer;
begin
  with TRegIniFile.Create(RegPath) do
    try
      Pkgs := TStringList.Create;
      try
        ReadSection(RegSection, Pkgs);
        for Loop := 0 to Pkgs.Count - 1 do
          LoadCustomPackage(Pkgs[Loop])
      finally
        Pkgs.Free
      end
    finally
      Free
    end
end;

procedure StorePackagesInRegistry;
var
  Loop: Integer;
begin
  with TRegIniFile.Create(RegPath) do
    try
      EraseSection(RegSection);
      for Loop := 0 to PackageList.Count - 1 do
        with TPackageRec(PackageList[Loop]^) do
          WriteString(RegSection, FileName, Description)
    finally
      Free
    end;
end;

procedure PackageInfoProc(const Name: string;
  NameType: TNameType; Flags: Byte; Param: Pointer);
type
  TRegisterProc = procedure;
var
  RegisterProc: TRegisterProc;
  UnitName, ProcName: String;
const
{$ifdef Ver100} //Delphi 3
  ExportName = '%s.BLRegister@51F89FF7';
{$else}
  ExportName = '@%s@BLRegister$qqrv';
{$endif}
begin
  if NameType = ntContainsUnit then
  begin
  {$ifdef Ver100} //Delphi 3
    //Delphi 3 packages don't use name-mangling
    //Unit names maintain their original case
    UnitName := Name;
  {$else}
    //Delphi 4+ mangles names - the unit name is all
    //lower case, with an initial capital letter
    UnitName := LowerCase(Name);
    if Length(UnitName) > 0 then
      UnitName[1] := UpCase(UnitName[1]);
  {$endif}
    ProcName := Format(ExportName, [UnitName]);
    @RegisterProc := GetProcAddress(PPackageRec(Param).Module, PChar(ProcName));
    if Assigned(RegisterProc) then
      try
        RegisterProc
      except
        on E: Exception do
          ShowMessageFmt('Error %s registering %s package',
            [E.ClassName, PPackageRec(Param).FileName])
      end
  end
end;

//Simple wrapper for SysUtils.LoadPackage which also adds to the package list
function LoadCustomPackage(const Name: String): HModule;
var
  P: PPackageRec;
  Loop, PackageFlags: integer;
begin
  for Loop := 0 to PackageList.Count - 1 do
    with TPackageRec(PackageList[Loop]^) do
      if AnsiCompareFileName(Name, FileName) = 0 then
        raise EPackageLoadError.CreateFmt(
          'Package already loaded:'#13'  %s'#13'  %s',
          [FileName, Description]);
  Result := LoadPackage(Name);
  New(P);
  P.Module := Result;
  P.FileName := Name;
  P.Description := GetPackageDescription(PChar(Name));
  CurrentGroup := NewAppGroup;
  P.Group := CurrentGroup;
  PackageList.Add(P);
  GetPackageInfo(P.Module, P, PackageFlags, PackageInfoProc);
end;

//Simple wrapper for SysUtils.UnloadPackage
//which also removes from the package list
procedure UnloadCustomPackage(PackageModule: HModule);
var
  Loop: Integer;
begin
  for Loop := 0 to PackageList.Count do
    if PPackageRec(PackageList[Loop]).Module = PackageModule then
    begin
      FreeAppGroup(PPackageRec(PackageList[Loop]).Group);
      UnloadPackage(PackageModule);
      Dispose(PackageList[Loop]);
      PackageList.Delete(Loop);
      Break
    end
end;

//Code to take the package list and extract a displayable subset
//The target TStrings object has the descriptions added,
//as well as the module handles (in the Objects array)
procedure FormatPackagesAsDisplayList(List: TStrings);
var
  Loop: Integer;
begin
  List.BeginUpdate;
  try
    List.Clear;
    for Loop := 0 to PackageList.Count - 1 do
      with TPackageRec(PackageList[Loop]^) do
        List.AddObject(Description, TObject(Module))
  finally
    List.EndUpdate
  end
end;

end.